perm filename IMDRAW[1,LMM] blob
sn#033097 filedate 1973-04-03 generic text, type T, neo UTF8
(PROGN (LISPXPRIN1 (QUOTE "FILE CREATED ")
T)
(LISPXPRIN1 (QUOTE "23-MAR-73 16:21:58")
T)
(LISPXTERPRI T))
(LISPXPRINT (QUOTE IMDRAWVARS)
T)
(RPAQQ IMDRAWVARS
((FNS XDRAW LABEL POSLABEL STARTDRAW STOPDRAW DELETEDRAW
INITDRAW LINE SETSCALE HOME XCENTER POS XPOSITION DLINA
DCHRA FLIPXY DGTCHR DINCS FNDCH OTCHRS SCALX SCALY SCALE
SETPOS POSCHRS POSCHR DPOS DXPOS CKPOS ERMES EXPTEXT
GRAPHTEXT MIN MAX RECIP SQUARE CLCINT YINTCP GEQ
OUTNDSTTY TOTPIC TSETSIZE TSETSCALE TSCALE TCSCALE TNODE
TNODES TLINE TLINEC TNODELINEC TNODELINE TINITDRAW GETLN
GETYLN GETXLN ROUND SIGN SETARR PUTPTS CHGCHR PROGRESS
DEFPAT FACES FACEF1 EDITFACE FACESIZE REEDITFACE OTFACE
DUPFACE SETEQ PATMATCH FACEMATCH NODEFACE FNODLST
NODEPICK1 NODEPICK2 NODEPICK3 PATNAME PATCONN PATFACE
PATNODFC PATLINE NODECHK PATPTS PATPOINTS CLCINTA)
(VARS DCHRS TTY PIC PATS CURPAT PATSELECT)
(FNS LAYOUT ANALIN SORTLN STRLNA FINDNDS STKNDS SETND RTLIN
CONCT OUTNDS CKINT SLOPE SRTLNA)
(FNS DRAW DRAWS PRINRAD PRINENTRY PAUSE)
(FNS /ONCOC RESETCOC SFCOC SETCOC M RFCOC PRINBRIT CLEAR
ONCOC)
(PROP MACRO RESETCOC)))
(DEFINEQ
(XDRAW
[LAMBDA (X Y)
(OTCHRS (DLINA (SCALX X)
(SCALY Y])
(LABEL
[LAMBDA (MS)
(GRAPHTEXT (EXPTEXT MS])
(POSLABEL
[LAMBDA (X Y MS)
(PROG2 (POS X Y)
(LABEL MS])
(STARTDRAW
[LAMBDA NIL
(PRIN1 (CHARACTER 14])
(STOPDRAW
[LAMBDA NIL
(PRIN1 (CHARACTER 15])
(DELETEDRAW
[LAMBDA NIL
(PROG2 (PRIN1 (CHARACTER 26))
(XCENTER])
(INITDRAW
[LAMBDA NIL
(PROG NIL
(ONCOC 14)
(ONCOC 15)
(ONCOC 26)
(SETSCALE 0 1024 0 1024)
(DELETEDRAW])
(LINE
[LAMBDA (X1 Y1 X2 Y2)
(PROG2 (POS X1 Y1)
(XDRAW X2 Y2])
(SETSCALE
[LAMBDA (XMN XMX YMN YMX)
(PROG NIL
(SETQ XBOT (MINUS XMN))
[SETQ XSCL (QUOTIENT 81.0 (PLUS 1 (DIFFERENCE XMX XMN]
(SETQ YBOT (MINUS YMN))
(SETQ YSCL (QUOTIENT 81.0 (PLUS 1 (DIFFERENCE YMX YMN])
(HOME
[LAMBDA NIL
(PROG2 (OTCHRS (LIST (CHARACTER 53)))
(SETPOS 0 80])
(XCENTER
[LAMBDA NIL
(PROG2 (OTCHRS (LIST (CHARACTER 45)))
(SETPOS 40 40])
(POS
[LAMBDA (X Y)
(OTCHRS (DPOS (SCALX X)
(SCALY Y])
(XPOSITION
[LAMBDA (X)
(OTCHRS (DXPOS (SCALX X])
(DLINA
[LAMBDA (X1 Y1)
(PROG (DX DY SL D L X Y SLA)
(SETQ DX (DIFFERENCE X1 XPOS))
(SETQ DY (DIFFERENCE Y1 YPOS))
(COND
((AND (ZEROP DX)
(ZEROP DY))
(RETURN NIL)))
[SETQ SL (COND
((ZEROP DX)
1024.0)
(T (ABS (QUOTIENT (FLOAT DY)
DX]
[SETQ SLA (COND
((ZEROP DY)
1024.0)
((ZEROP DX)
0.0)
(T (RECIP SL]
(SETQ INC 0.0)
(SETQ Y (GREATERP (ABS DX)
(ABS DY)))
A [SETQ D (COND
(Y (DCHRA DX DY SL))
(T (FLIPXY (DCHRA DY DX SLA]
(SETQ X (DINCS D))
(SETQ L (CONS (DGTCHR D)
L))
(SETQ DX (DIFFERENCE DX (CAR X)))
(SETQ DY (DIFFERENCE DY (CADR X)))
(SETPOS (PLUS XPOS (CAR X))
(PLUS YPOS (CADR X)))
[COND
[(CKPOS)
(RETURN (REVERSE (CDR L]
((AND (ZEROP DX)
(ZEROP DY))
(RETURN (REVERSE L]
(GO A])
(DCHRA
[LAMBDA (DX DY SL)
(PROG (X Y)
(SETQ X (FIX (PLUS INC SL SL .5)))
[COND
((ZEROP X)
NIL)
((GREATERP DY 0)
(SETQ X (DIFFERENCE 16 X]
[COND
((LESSP DX 0)
(SETQ X (DIFFERENCE 8 X]
[COND
((LESSP X 0)
(SETQ X (PLUS X 16]
(SETQ Y (COND
((AND (EQUAL SL 0)
(GREATERP (ABS DX)
7))
8)
((GREATERP (ABS DX)
1)
2)
(T 1)))
(SETQ INC (PLUS INC (TIMES Y SL)))
(SETQ DX (FIX (PLUS INC .5)))
(SETQ INC (DIFFERENCE INC DX))
(RETURN (LIST Y X])
(FLIPXY
[LAMBDA (X)
(PROG (Y)
(SETQ Y (DIFFERENCE 12 (CADR X)))
[COND
((MINUSP Y)
(SETQ Y (PLUS 16 Y]
(RETURN (LIST (CAR X)
Y])
(DGTCHR
[LAMBDA (DD)
(CAR (FNDCH D])
(DINCS
[LAMBDA (D)
(CADDR (FNDCH D])
(FNDCH
[LAMBDA (D)
(PROG (X)
(SETQ X DCHRS)
A [COND
((NULL X)
(RETURN NIL))
((EQUAL D (CADAR X))
(RETURN (CAR X]
(SETQ X (CDR X))
(GO A])
(OTCHRS
[LAMBDA (L)
(PROG (X)
(STARTDRAW)
(FOR X IN L DO (PRIN1 X))
(STOPDRAW])
(SCALX
[LAMBDA (X)
(SCALE X XBOT XSCL])
(SCALY
[LAMBDA (Y)
(SCALE Y YBOT YSCL])
(SCALE
[LAMBDA (X XMN XMP)
(PROG NIL
(SETQ X (FIX (PLUS (TIMES XMP (PLUS X XMN))
.5)))
(RETURN (COND
((LESSP X 0)
0)
((GREATERP X 80)
80)
(T X])
(SETPOS
[LAMBDA (X Y)
(PROG NIL
(SETQ XPOS X)
(SETQ YPOS Y])
(POSCHRS
[LAMBDA (X)
(PROG (X1)
(SETQ X (PLUS (TIMES X 2)
48))
(SETQ X1 (FIX (QUOTIENT X 16)))
(SETQ X (DIFFERENCE X (TIMES X1 16)))
(RETURN (LIST (POSCHR X1)
(POSCHR X])
(POSCHR
[LAMBDA (X)
(PROG (Y)
[SETQ Y
(CONS (CHARACTER 64)
(QUOTE (A B C D E F G H I J K L M N O]
A [COND
((ZEROP X)
(RETURN (CAR Y]
(SETQ X (SUB1 X))
(SETQ Y (CDR Y))
(GO A])
(DPOS
[LAMBDA (X Y)
(PROG NIL
(SETPOS X Y)
(CKPOS)
(RETURN (CONS (CHARACTER 46)
(APPEND (POSCHRS X)
(POSCHRS Y])
(DXPOS
[LAMBDA (X)
(PROG NIL
(SETQ XPOS X)
(CKPOS)
(RETURN (CONS (CHARACTER 42)
(POSCHRS (SCALX X])
(CKPOS
[LAMBDA NIL
(PROG NIL
(COND
((OR (GREATERP XPOS 80)
(MINUSP XPOS))
(GO A))
((OR (GREATERP YPOS 80)
(MINUSP YPOS))
(GO B))
(T (RETURN NIL)))
A (ERMES (QUOTE (X POS OFF SCREEN)))
(SETQ XPOS (MIN 80 (MAX 0 XPOS)))
C (DPOS XPOS YPOS)
(RETURN T)
B (ERMES (QUOTE (Y POS OFF SCREEN)))
(SETQ YPOS (MIN 80 (MAX 0 YPOS)))
(GO C])
(ERMES
[LAMBDA (MS)
(PROG NIL
(STOPDRAW)
(PRINT MS)
(STARTDRAW)
(RETURN NIL])
(EXPTEXT
[LAMBDA (X)
(PROG (L Y Z)
[COND
((ATOM X)
(SETQ X (LIST X]
[FOR Y IN X DO (SETQ L (APPEND L (CONS (CHARACTER 32)
(UNPACK Y]
(RETURN L])
(GRAPHTEXT
[LAMBDA (X)
(PROG (Y)
(STARTDRAW)
(FOR Y IN X DO (SETQ XPOS (ADD1 XPOS))
(COND
((CKPOS)
(RETURN NIL)))
(PRIN1 (CHARACTER 44))
(PRIN1 Y))
A (STOPDRAW)
(RETURN NIL])
(MIN
[LAMBDA (X Y)
(COND
((LESSP X Y)
X)
(T Y])
(MAX
[LAMBDA (X Y)
(COND
((LESSP X Y)
Y)
(T X])
(RECIP
[LAMBDA (X)
(COND
((ZEROP X)
1024)
(T (QUOTIENT 1.0 X])
(SQUARE
[LAMBDA (X)
(PRINBRIT "-90YZ"])
(CLCINT
[LAMBDA (X1 Y1 X2 Y2 R1 S1 R2 S2)
(PROG (U1 U2 V1 V2)
(SETQ V1 (IDIFFERENCE X2 X1))
(SETQ V2 (IDIFFERENCE R2 R1))
(SETQ U1 (IDIFFERENCE (ITIMES (IDIFFERENCE (ITIMES S1 R2)
(ITIMES R1 S2))
V1)
(ITIMES (IDIFFERENCE (ITIMES Y1 X2)
(ITIMES X1 Y2))
V2)))
(SETQ U2 (IDIFFERENCE (ITIMES (IDIFFERENCE Y2 Y1)
V2)
(ITIMES (IDIFFERENCE S2 S1)
V1)))
(RETURN (CONS U1 U2])
(YINTCP
[LAMBDA (X1 X2 Y1 Y2)
(CONS (IDIFFERENCE (ITIMES Y1 X2)
(ITIMES X1 Y2))
(IDIFFERENCE X2 X1])
(GEQ
[LAMBDA (X Y)
(OR (GREATERP X Y)
(EQ X Y])
(OUTNDSTTY
[LAMBDA NIL
(PROG (X Y)
(TINITDRAW)
(FOR X :=(1 NMX) IF (NOT (ZEROP (ELT NODE X)))
DO (TNODES (ELT NODE X)
(ELT NODE (IPLUS X 20))
(CDR (FASSOC X LABEL))
X))
(SETQ Y (QUOTE (* = 3 4 5 6 7 8 9)))
[FOR X IN (CAR (LAST STACK))
DO (TNODELINEC (CAAR X)
(CDAR X)
(CAR (FNTH Y (CADR X]
(TOTPIC)
(TERPRI)
(PRINT TITLE)
(TERPRI)
(TERPRI)
(TERPRI)
(RETURN NIL])
(TOTPIC
[LAMBDA NIL
(PROG (X Y Z X1)
(TERPRI)
(TERPRI)
(TERPRI)
[SETQ X1 (FOR X :=((ARRAYSIZE PIC)
1 -1) DO (COND
((ELT PIC X)
(RETURN X]
(COND
((NULL X1)
(SETQ X1 1)))
[FOR X :=(1 X1)
AS Y IS (ELT PIC X)
DO (COND
((NOT (OR Y Z))
NIL)
(T (PROG NIL
(SETQ Z T)
(MAPC (FNTH Y LINMIN)
(FUNCTION PRIN1))
(TERPRI]
(RETURN NIL])
(TSETSIZE
[LAMBDA (X Y)
(PROG2 (SETQ HSIZE X)
(SETQ VSIZE Y])
(TSETSCALE
[LAMBDA (XMN XMX YMN YMX)
(PROG (XSP YSP X)
(SETQ XSP (DIFFERENCE XMX XMN))
(SETQ YSP (DIFFERENCE YMX YMN))
(SETQ X (MIN (QUOTIENT HSIZE XSP)
(QUOTIENT VSIZE YSP)))
[COND
((GREATERP X 1)
(SETQ X (FLOAT (FIX X]
(SETQ XD X)
(SETQ YD X)
(SETQ XMIN XMN)
(SETQ YMIN YMN)
(SETARR XMX YMX)
(RETURN NIL])
(TSCALE
[LAMBDA (X Y)
(CONS (TCSCALE X XMIN XD)
(TCSCALE Y YMIN YD])
(TCSCALE
[LAMBDA (X MN DL)
(ADD1 (FIX (TIMES (DIFFERENCE X MN)
DL])
(TNODE
[LAMBDA (X Y LBL)
(PROG NIL
(SETQ LBL (UNPACK LBL))
(SETQ X (TSCALE X Y))
(SETQ LINMIN (MIN (CAR X)
LINMIN))
A (CHGCHR (CAR X)
(CDR X)
(CAR LBL))
(SETQ LBL (CDR LBL))
(COND
((NULL LBL)
(RETURN NIL)))
(RPLACA X (ADD1 (CAR X)))
(GO A])
(TNODES
[LAMBDA (X Y LBL ID)
(PROG NIL
(SETQ NODS (CONS (LIST ID X Y)
NODS))
(TNODE X Y LBL])
(TLINE
[LAMBDA (X1 Y1 X2 Y2)
(TLINEC X1 Y1 X2 Y2 (QUOTE *])
(TLINEC
[LAMBDA (X1 Y1 X2 Y2 CH)
(PROG (Z1 Z2)
(SETQ Z1 (TSCALE X1 Y1))
(SETQ Z2 (TSCALE X2 Y2))
(PUTPTS (GETLN (CAR Z1)
(CDR Z1)
(CAR Z2)
(CDR Z2))
CH])
(TNODELINEC
[LAMBDA (N1 N2 CH)
(PROG (X Y)
(SETQ X (FASSOC N1 NODS))
(SETQ Y (FASSOC N2 NODS))
[COND
((AND X Y)
NIL)
(T (RETURN (PRINT (QUOTE (NODE NOT DEFINED]
(TLINEC (CADR X)
(CADDR X)
(CADR Y)
(CADDR Y)
CH])
(TNODELINE
[LAMBDA (N1 N2)
(TNODELINEC N1 N2 (QUOTE *])
(TINITDRAW
[LAMBDA NIL
(PROG NIL
(SETQ NODS NIL)
(SETQ LINMIN 100)
(TSETSIZE 60 60)
(TSETSCALE 11 20 11 20])
(GETLN
[LAMBDA (X Y NX NY)
(PROG (X1 Y1)
(SETQ X1 (IDIFFERENCE NX X))
(SETQ Y1 (IDIFFERENCE NY Y))
(RETURN (COND
((GEQ (ABS X1)
(ABS Y1))
(GETXLN X Y NX NY X1 Y1))
(T (GETYLN X Y NX NY X1 Y1])
(GETYLN
[LAMBDA (X Y NX NY X1 Y1)
(PROG (LX Z)
(SETQ LX (GETXLN Y X NY NX Y1 X1))
(RETURN (FOR Z IN LX LIST (CONS (CDR Z)
(CAR Z])
(GETXLN
[LAMBDA (X Y NX NY X1 Y1)
(PROG (SL B X2 LX)
(SETQ SL (FQUOTIENT (FLOAT Y1)
(FLOAT X1)))
(SETN B (FLOAT Y))
A (SETQ LX (CONS (CONS X Y)
LX))
(SETQ X2 (SIGN X NX))
[COND
((ZEROP X2)
(RETURN (REVERSE LX)))
((MINUSP X2)
(SETN B (DIFFERENCE B SL)))
(T (SETN B (FPLUS B SL]
(SETQ X (IPLUS X X2))
(SETQ Y (FIX (FPLUS B .5)))
(GO A])
(ROUND
[LAMBDA (X)
(FIX (FPLUS X .5])
(SIGN
[LAMBDA (X Y)
(PROG (X1 X2)
(SETQ X1 (DIFFERENCE X Y))
(RETURN (COND
((LESSP (ABS X1)
.5)
0)
((MINUSP X1)
1.0)
(T -1.0])
(SETARR
[LAMBDA (XMX YMX)
(PROG (X Y)
(SETQ X (TSCALE XMX YMX))
(COND
((NOT (ARRAYP PIC))
(GO A))
((LESSP (ARRAYSIZE PIC)
(CDR X))
(GO A))
(T (GO B)))
A (SETQ PIC (ARRAY (CDR X)
NIL NIL))
C (SETQ NILINES (CDR X))
(RETURN X)
B (FOR Y :=(1 (CDR X)) DO (SETA PIC Y NIL))
(GO C])
(PUTPTS
[LAMBDA (LX CHR)
(PROG (X)
(FOR X IN LX DO (CHGCHR (CAR X)
(CDR X)
CHR])
(CHGCHR
[LAMBDA (X Y CHR)
(PROG (Z1 Z2 Z3)
(SETQ Z1 (ELT PIC Y))
(SETQ Z2 (IDIFFERENCE X (LENGTH Z1)))
(COND
((MINUSP Z2)
(GO A))
((ZEROP Z2)
(GO A)))
[FOR Z3 :=(1 Z2) DO (SETQ Z1 (NCONC1 Z1 (QUOTE % ]
A (SETQ Z3 (NTH Z1 X))
(COND
((EQ (CAR Z3)
(QUOTE % ))
(RPLACA Z3 CHR)))
(SETA PIC Y Z1)
(RETURN Z1])
(PROGRESS
[LAMBDA NIL
(FOR NEW X :=(1 NMX)
DO (PRINT (LIST X (ELT NODE X)
(ELT NODE (IPLUS X 20])
(DEFPAT
[LAMBDA (X Y)
(PROG (X1 X2 X3 X4)
[COND
([NOT (ARRAYP (CAR (QUOTE CONN]
(SETQ CONN (ARRAY 20 0 NIL)))
(T (FOR X1 :=(1 20) DO (SETA CONN X1 NIL]
(ANALIN X)
(SETQ X2 (FACES))
(SETQ PATS (NCONC1 PATS (LIST TITLE
(FOR X1 :=(1 NMX)
AS X3 IS (ELT CONN X1)
IF X3 LIST (CONS X1 X3))
X2
(NODEFACE X2)
LINE Y)))
(RETURN (CAAR PATS])
(FACES
[LAMBDA NIL
(PROG (X)
(SETQ FACE NIL)
(SETQ FACENUM 0)
(FOR X :=(1 (IPLUS NMX -2))
DO (FACEF1 X X NIL (ADD1 (IDIFFERENCE NMX X))
1))
(EDITFACE)
(RETURN FACE])
(FACEF1
[LAMBDA (FST Z LST MXLV LV)
(PROG (X Y)
(SETQ Y (ELT CONN Z))
A (COND
((NULL Y)
(RETURN NIL)))
(SETQ X (CAR Y))
[COND
((EQ X FST)
(OTFACE FST LST))
((FMEMB X LST)
NIL)
((EQ LV MXLV)
NIL)
(T (FACEF1 FST X (CONS X LST)
MXLV
(ADD1 LV]
(SETQ Y (CDR Y))
(GO A])
(EDITFACE
[LAMBDA NIL
(PROG (X)
[SETQ FACE (SORT FACE (FUNCTION (LAMBDA (X Y)
(GREATERP (FACESIZE X)
(FACESIZE Y]
(SETQ X (MAPCAR FACE (FUNCTION FACESIZE)))
(SETQ FACE (LIST (FLENGTH X)
X FACE))
(RETURN FACE])
(FACESIZE
[LAMBDA (X)
(FLENGTH (CADDR X])
(REEDITFACE
[LAMBDA (X)
(PROG (Y Z Y1 Z1)
(SETQ Y1 (SETQ Y (CADR X)))
[SETQ Z1 (SETQ Z (MAPCAR (CADDR X)
(FUNCTION LIST]
(COND
((NULL Y)
(GO A)))
B (COND
((NULL (CDR Y))
(GO A))
((EQ (CAR Y)
(CADR Y))
(GO C)))
(SETQ Y (CDR Y))
(SETQ Z (CDR Z))
(GO B)
C (RPLACD Y (CDDR Y))
(RPLACD (CADR Z)
(CAR Z))
(RPLACA Z (CADR Z))
(RPLACD Z (CDDR Z))
(GO B)
A (RETURN (LIST (CAR X)
Y1 Z1])
(OTFACE
[LAMBDA (X Y)
(PROG NIL
(COND
((EQ (FLENGTH Y)
1)
(RETURN NIL)))
(SETQ X (CONS X Y))
(COND
((DUPFACE X)
(RETURN NIL)))
(SETQ FACENUM (ADD1 FACENUM))
(SETQ FACE (CONS (LIST FACENUM (FLENGTH X)
X)
FACE))
(RETURN NIL])
(DUPFACE
[LAMBDA (X)
(FOR NEW Y IN FACE OR (SETEQ X (CADDR Y])
(SETEQ
[LAMBDA (X Y)
(AND (EQ (FLENGTH X)
(FLENGTH Y))
(EQ (FLENGTH X)
(FLENGTH (UNION X Y])
(PATMATCH
[LAMBDA NIL
(PROG (X1 X2 Y)
(SETQ X1 (REEDITFACE (FACES)))
(SETQ X2 PATS)
B (SETQ CURPAT (CAR X2))
[SETQ Y (FACEMATCH X1 (PATFACE (CAR X2]
(COND
((NULL Y)
(GO A)))
[SETQ Y (NODEPICK1 Y (PATNODFC (CAR X2]
(SETQ Y (NODEPICK2 Y))
[COND
(Y (RETURN (SETQ PATSELECT (PATPTS Y (PATPOINTS CURPAT]
A (SETQ X2 (CDR X2))
(COND
(X2 (GO B)))
(RETURN NIL])
(FACEMATCH
[LAMBDA (F1 F2)
(PROG (X1 X2 Y1 Y2 Z)
(COND
((LESSP (CAR F1)
(CAR F2))
(RETURN NIL)))
(SETQ X1 (CADR F1))
(SETQ X2 (CADR F2))
(SETQ Y1 (CADDR F1))
(SETQ Y2 (CADDR F2))
A (COND
((LESSP (CAR X1)
(CAR X2))
(RETURN NIL))
((EQ (CAR X1)
(CAR X2))
(GO B)))
(SETQ X1 (CDR X1))
(SETQ Y1 (CDR Y1))
(COND
((NULL X1)
(RETURN NIL)))
(GO A)
B (SETQ Z (CONS (CONS (CAAR Y2)
(CAR Y1))
Z))
(SETQ X2 (CDR X2))
(SETQ Y2 (CDR Y2))
(COND
(X2 (GO A)))
(RETURN Z])
(NODEFACE
[LAMBDA (F1)
(PROG (X LST Y Z)
(FOR X :=(1 NMX) IF (ELT CONN X)
DO (SETQ Y NIL)
(SETQ Z (CADDR F1))
A
[COND
((FMEMB X (CADDAR Z))
(SETQ Y (CONS (CAAR Z)
Y]
(SETQ Z (CDR Z))
(COND
(Z (GO A)))
(SETQ LST (CONS (CONS X Y)
LST)))
(RETURN LST])
(FNODLST
[LAMBDA (X)
(PROG (Y Y1)
(SETQ Y (CDR X))
(SETQ Y1 (CADDAR Y))
B (SETQ Y (CDR Y))
(COND
((NULL Y)
(GO A)))
(SETQ Y1 (UNION Y1 (CADDAR Y)))
(GO B)
A (RETURN (CONS (CAR X)
Y1])
(NODEPICK1
[LAMBDA (FCM NF)
(PROG (X Y Y1 Z Y2)
(SETQ X (MAPCAR FCM (FUNCTION FNODLST)))
(SETQ Y1 (FOR Y
IN NF LIST (SETQ Y2 (CDR Y))
(SETQ Z NIL)
(COND
((NULL Y2)
(GO A)))
(SETQ Z (CDR (FASSOC (CAR Y2)
X)))
B
(SETQ Y2 (CDR Y2))
(COND
((NULL Y2)
(GO A)))
[SETQ Z (INTERSECTION
Z
(CDR (FASSOC (CAR Y2)
X]
(GO B)
A
(CONS (CAR Y)
Z)))
(RETURN Y1])
(NODEPICK2
[LAMBDA (PS)
(NODEPICK3 PS NIL NIL])
(NODEPICK3
[LAMBDA (PS1 LST USD)
(PROG (X Y)
(SETQ X (CDAR PS1))
B [COND
((NULL X)
(RETURN NIL))
((FMEMB (CAR X)
USD)
NIL)
((CDR PS1)
(GO A))
(T (RETURN (CONS (CONS (CAAR PS1)
(CAR X))
LST]
C (SETQ X (CDR X))
(GO B)
A (COND
((NOT (NODECHK (CAAR PS1)
(CAR X)
LST))
(GO C)))
(SETQ Y (NODEPICK3 (CDR PS1)
(CONS (CONS (CAAR PS1)
(CAR X))
LST)
(CONS (CAR X)
USD)))
(COND
(Y (RETURN Y)))
(GO C])
(PATNAME
[LAMBDA (X)
(CAR X])
(PATCONN
[LAMBDA (X)
(CADR X])
(PATFACE
[LAMBDA (X)
(CADDR X])
(PATNODFC
[LAMBDA (X)
(CADDDR X])
(PATLINE
[LAMBDA (X)
(CAR (CDDDDR X])
(NODECHK
[LAMBDA (PX NX LST)
(PROG (Y Y1 Y2)
(SETQ Y2 (ELT CONN NX))
(RETURN (FOR Y IN (CDR (FASSOC PX (PATCONN CURPAT)))
AS Y1 IS (FASSOC Y LST)
IF Y1 AND (MEMBER (CDR Y1)
Y2])
(PATPTS
[LAMBDA (X LC)
(FOR NEW Y IN X AS NEW Z IS (FASSOC (CAR Y)
LC)
LIST
(LIST (CDR Y)
(IPLUS (CADR Z)
15)
(IPLUS (CADDR Z)
15])
(PATPOINTS
[LAMBDA (X)
(CADR (CDDDDR X])
(CLCINTA
[LAMBDA (X X1 X2)
(NOT (MINUSP (ITIMES (IDIFFERENCE (CAR X)
(ITIMES X1 (CDR X)))
(IDIFFERENCE (CAR X)
(ITIMES X2 (CDR X])
)
[RPAQQ DCHRS ((0 (8 4)
(0 -8))
(1 (1 0)
(1 0))
(2 (1 2)
(1 -1))
(3 (1 4)
(0 -1))
(4 (1 6)
(-1 -1))
(5 (1 8)
(-1 0))
(6 (1 10)
(-1 1))
(7 (1 12)
(0 1))
(8 (1 14)
(1 1))
(9 (8 0)
(8 0))
(A (2 0)
(2 0))
(B (2 1)
(2 -1))
(C (2 2)
(2 -2))
(D (2 3)
(1 -2))
(E (2 4)
(0 -2))
(F (2 5)
(-1 -2))
(G (2 6)
(-2 -2))
(H (2 7)
(-2 -1))
(I (2 8)
(-2 0))
(J (2 9)
(-2 1))
(K (2 10)
(-2 2))
(L (2 11)
(-1 2))
(M (2 12)
(0 2))
(N (2 13)
(1 2))
(O (2 14)
(2 2))
(P (2 15)
(2 1))
(Q (-1 0)
(1 0))
(R (-1 2)
(1 -1))
(S (-1 4)
(0 -1))
(T (-1 6)
(-1 -1))
(U (-1 8)
(-1 0))
(V (-1 10)
(-1 1))
(W (-1 12)
(0 1))
(X (-1 14)
(1 1))
(Y (8 8)
(-8 0))
(Z (8 12)
(0 8]
(RPAQQ TTY TTY)
(RPAQQ PIC #502336)
[RPAQQ PATS
((TRAP ((1 4 3 2)
(2 4 3 1)
(3 4 2 1)
(4 3 2 1))
[5 (4 3 3 3 3)
((1 4 (1 2 3 4))
(2 3 (1 3 4))
(3 3 (1 2 4))
(4 3 (1 2 3))
(5 3 (2 3 4]
((4 5 3 2 1)
(3 5 4 2 1)
(2 5 4 3 1)
(1 4 3 2 1))
(((3 . 4)
1)
((2 . 4)
1)
((2 . 3)
1)
((1 . 4)
1)
((1 . 3)
1)
((1 . 2)
1))
((1 0 0)
(2 1 2)
(3 2 0)
(4 1 1)))
(HEX ((1 2 6)
(2 3 1)
(3 4 2)
(4 5 3)
(5 6 4)
(6 5 1))
[1 (6)
((1 6 (1 6 5 4 3 2]
((6 1)
(5 1)
(4 1)
(3 1)
(2 1)
(1 1))
(((5 . 6)
1)
((4 . 5)
1)
((3 . 4)
1)
((2 . 3)
1)
((1 . 2)
1)
((1 . 6)
1))
((1 1 3)
(2 2 2)
(3 2 1)
(4 1 0)
(5 0 1)
(6 0 2)))
(PENT ((1 5 2)
(2 3 1)
(3 4 2)
(4 5 3)
(5 1 4))
[1 (5)
((1 5 (1 2 3 4 5]
((5 1)
(4 1)
(3 1)
(2 1)
(1 1))
(((4 . 5)
1)
((3 . 4)
1)
((2 . 3)
1)
((1 . 5)
1)
((1 . 2)
1))
((1 0 1)
(2 1 2)
(3 2 1)
(4 2 0)
(5 0 0)))
(OCT ((1 2 8)
(2 3 1)
(3 4 2)
(4 5 3)
(5 6 4)
(6 7 5)
(7 8 6)
(8 1 7))
[1 (8)
((1 8 (1 8 7 6 5 4 3 2]
((8 1)
(7 1)
(6 1)
(5 1)
(4 1)
(3 1)
(2 1)
(1 1))
(((7 . 8)
1)
((6 . 7)
1)
((5 . 6)
1)
((4 . 5)
1)
((3 . 4)
1)
((2 . 3)
1)
((1 . 2)
1)
((1 . 8)
1))
((1 0 2)
(2 1 3)
(3 2 3)
(4 3 2)
(5 3 1)
(6 2 0)
(7 1 0)
(8 0 1]
[RPAQQ CURPAT (TRAP ((1 4 3 2)
(2 4 3 1)
(3 4 2 1)
(4 3 2 1))
[5 (4 3 3 3 3)
((1 4 (1 2 3 4))
(2 3 (1 3 4))
(3 3 (1 2 4))
(4 3 (1 2 3))
(5 3 (2 3 4]
((4 5 3 2 1)
(3 5 4 2 1)
(2 5 4 3 1)
(1 4 3 2 1))
(((3 . 4)
1)
((2 . 4)
1)
((2 . 3)
1)
((1 . 4)
1)
((1 . 3)
1)
((1 . 2)
1))
((1 0 0)
(2 1 2)
(3 2 0)
(4 1 1]
(RPAQQ PATSELECT ((4 15 15)
(3 16 17)
(1 17 15)
(2 16 16)))
(DEFINEQ
(LAYOUT
[LAMBDA (X)
(PROG (X1)
[COND
([NOT (ARRAYP (CAR (QUOTE NODE]
(SETQ NODE (ARRAY 40 0 0)))
(T (FOR X1 :=(1 40) DO (SETA NODE X1 0]
[COND
([NOT (ARRAYP (CAR (QUOTE CONN]
(SETQ CONN (ARRAY 20 0 NIL)))
(T (FOR X1 :=(1 20) DO (SETA CONN X1 NIL]
(OR (ARRAYP (CAR (QUOTE TMP)))
(SETQ TMP (ARRAY 20 0 0)))
(ANALIN X)
(PATMATCH)
(SORTLN)
(FINDNDS 1 NIL)
(SETQ X1 (OUTNDS))
(RETURN X1])
(ANALIN
[LAMBDA (X)
(PROG (X1 X2 X3 X4)
(SETQ TITLE (CAR X))
(SETQ LINE NIL)
(SETQ LABEL NIL)
(SETQ NLN (LENGTH (CDR X)))
(SETQ NMX 0)
[FOR X1 IN (CDR X)
AS NMX IS (MAX (CAR X1)
NMX)
AS X2 IS (CAR X1)
AS LABEL IS (CONS (CONS X2 (CADR X1))
LABEL) FOR X3
IN (CDDR X1)
DO (SETQ X4 (SASSOC (CONS X2 X3)
LINE))
[COND
[(NULL X4)
(COND
((SASSOC (CONS X3 X2)
LINE)
NIL)
(T (SETQ LINE (CONS (LIST (CONS X2 X3)
1)
LINE]
(T (RPLACA (CDR X4)
(ADD1 (CADR X4]
(COND
((MEMBER X3 (ELT CONN X2))
NIL)
(T (SETA CONN X2 (CONS X3 (ELT CONN X2]
(SETQ LLN (LENGTH LINE))
(RETURN LINE])
(SORTLN
[LAMBDA NIL
(PROG (L X X1 X2 X3 Y Y1)
[FOR I :=(1 NMX) DO (SETA TMP I (LENGTH (ELT CONN I]
(FOR I IN PATSELECT DO (SETA TMP (CAR I)
20))
(SETQ L NIL)
(SETQ Y1 (TIMES NMX 10))
(SETQ Y NIL)
A (SETQ X1 0)
(SETQ X2 NIL)
[FOR X IN LINE IF (NOT (MEMBER X L))
DO [SETQ X3 (PLUS (ELT TMP (CAAR X))
(ELT TMP (CDAR X]
(COND
((LESSP X1 X3)
(PROG2 (SETQ X1 X3)
(SETQ X2 X]
[COND
((AND Y (NOT (MEMBER (CAAR X2)
Y)))
(RPLACA X2 (CONS (CDAR X2)
(CAAR X2]
(SETQ Y (SRTLNA (CAAR X2)
Y Y1))
(SETQ Y (SRTLNA (CDAR X2)
Y Y1))
(SETQ Y1 (PLUS Y1 -10))
(SETQ L (CONS X2 L))
(COND
((LESSP (LENGTH L)
LLN)
(GO A)))
(SETQ LINE (REVERSE L))
(RETURN LINE])
(STRLNA
[LAMBDA (X Y Y1)
(PROG NIL
(COND
((MEMBER X Y)
(RETURN Y)))
(SETA TMP X (PLUS (ELTA TMP X)
Y1))
(RETURN (CONS X Y])
(FINDNDS
[LAMBDA (RA RI)
(PROG (X1 X2 X3 L1)
(COND
(PATSELECT (SETQ RI T)))
F (FOR I :=(1 NMX) DO (SETA NODE I 0)
(SETA NODE (IPLUS 20 I)
0))
(SETQ X1 (FASSOC (CAAAR LINE)
PATSELECT))
[COND
[X1 (SETND (CAR X1)
(CONS (CADR X1)
(CADDR X1]
(T (SETND (CAAAR LINE)
(QUOTE (15 . 15]
(SETQ STACK (LIST 0 LINE))
(SETQ L1 NIL)
(SETQ X3 T)
C (SETQ X1 (CAR LINE))
(SETQ X2 (CDAR X1))
(COND
((ZEROP (ELT NODE X2))
NIL)
((RTLIN RI X1 L1)
(GO B))
(T (GO A)))
(COND
(X3 (STKNDS X2 L1)))
A (SETQ X3 (CAR STACK))
(SETQ STACK (CDR STACK))
(COND
((ATOM X3)
(GO D)))
(SETND (CADR X3)
(CAR X3))
(COND
((RTLIN RI X1 L1)
(GO G)))
(SETND (CADR X3)
(QUOTE (0 . 0)))
(GO A)
NXT (SETQ L1 (CONS X1 L1))
(SETQ LINE (CDR LINE))
(SETQ X3 T)
(COND
(LINE (GO C))
(T (RETURN NIL)))
G [SETQ STACK (CONS NIL (CONS LINE (CONS L1 STACK]
(GO NXT)
B [SETQ STACK (CONS NIL (CONS (CONS (CAR L1)
LINE)
(CONS (CDR L1)
STACK]
(GO NXT)
D (SETQ LINE (CAR STACK))
(SETQ L1 (CADR STACK))
(SETQ STACK (CDDR STACK))
(SETQ X1 (CAR LINE))
(COND
((NULL STACK)
(GO E)))
[COND
(X3 (SETND X3 (QUOTE (0 . 0]
(COND
((ATOM (CAR STACK))
(GO A)))
(SETA NODE (CADAR STACK)
0)
(SETQ X3 NIL)
(GO C)
E [COND
(PATSELECT (PROG NIL
(SETQ RI NIL)
(SETQ PATSELECT NIL)
(SETQ RA 0]
(SETQ RA (ADD1 RA))
(COND
((GREATERP RA 3)
(SETQ RI T)))
(GO F])
(STKNDS
[LAMBDA (X L1)
(PROG (Y X1 XNM XMX YMN YMX N1 N2)
[SETQ STACK (CONS X (CONS (CONS (CAR L1)
LINE)
(CONS (CDR L1)
STACK]
(COND
((NULL PATSELECT)
(GO A)))
(SETQ X1 (FASSOC X PATSELECT))
(COND
((NULL X1)
(GO A)))
(SETQ STACK (CONS (LIST (CONS (CADR X1)
(CADDR X1))
X)
STACK))
(RETURN T)
A (SETQ XMN 0)
(SETQ XMX 100)
(SETQ YMN 0)
(SETQ YMX 100)
[COND
((LESSP (LENGTH STACK)
6)
(PROG2 (SETQ XMN 16)
(SETQ YMN 15]
[FOR X1 IN (ELT CONN X)
AS N1 IS (ELT NODE X1)
IF (NOT (ZEROP N1))
AS N2 IS (ELT NODE (IPLUS X1 20))
DO (SETQ XMN (MAX XMN (IDIFFERENCE N1 RA)))
(SETQ XMX (MIN XMX (IPLUS N1 RA)))
(SETQ YMN (MAX YMN (IDIFFERENCE N2 RA)))
(SETQ YMX (MIN YMX (IPLUS N2 RA]
(COND
((OR (GREATERP XMN XMX)
(GREATERP YMN YMX))
(RETURN NIL)))
[SETQ Y (FOR I :=(1 NMX)
LIST
(CONS (ELT NODE I)
(ELT NODE (IPLUS I 20]
(SETQ X1 NIL)
(FOR N1 :=(XMN XMX) FOR N2 :=(YMN YMX)
IF (NOT (MEMBER (CONS N1 N2)
Y))
DO (SETQ X1 T)
(SETQ STACK (CONS (LIST (CONS N1 N2)
X)
STACK)))
(COND
((NULL X1)
(RETURN NIL)))
(RETURN T])
(SETND
[LAMBDA (X Y)
(PROG NIL
(SETA NODE X (CAR Y))
(SETA NODE (IPLUS X 20)
(CDR Y))
(RETURN Y])
(RTLIN
[LAMBDA (RI X L1)
(PROG (X1 X2 Y1 Y2 N1 N2 Y SL IN Z)
(COND
((NULL L1)
(RETURN T)))
(SETQ N1 (CAAR X))
(SETQ N2 (CDAR X))
(SETQ X1 (ELT NODE N1))
(SETQ X2 (ELT NODE N2))
(SETQ Y1 (ELT NODE (IPLUS N1 20)))
(SETQ Y2 (ELT NODE (IPLUS N2 20)))
(SETQ SL (SLOPE X1 X2 Y1 Y2))
(SETQ IN (YINTCP X1 X2 Y1 Y2))
[SETQ Z
(FOR Y
IN L1 AS Z IS (CONCT X Y)
AS N1 IS (CAAR Y)
AS N2 IS (CDAR Y)
AND (CKINT Z RI X1 X2 Y1 Y2 SL
IN (ELT NODE N1)
(ELT NODE N2)
(ELT NODE (IPLUS N1 20))
(ELT NODE (IPLUS N2 20]
(RETURN Z])
(CONCT
[LAMBDA (X Y)
(OR (EQ (CAAR Y)
(CAAR X))
(EQ (CAAR Y)
(CDAR X))
(EQ (CDAR Y)
(CAAR X))
(EQ (CDAR Y)
(CDAR X])
(OUTNDS
[LAMBDA NIL
(PROG (X I X1)
[COND
((EQ TTY (QUOTE IMLAC))
NIL)
(T (RETURN (OUTNDSTTY]
(INITDRAW)
(SETSCALE 10 20 10 20)
(POSLABEL 13 13 TITLE)
(FOR I :=(1 NMX) WHEN (NOT (ZEROP (ELT NODE I)))
AS NEW LL IS (CDR (ASSOC I LABEL))
DO (POSLABEL (ELT NODE I)
(ELT NODE (IPLUS I 20))
(OR LL I)))
[FOR NEW LIN IN (CAR (LAST STACK))
DO (LINE (ELT NODE (CAAR LIN))
(ELT NODE (IPLUS (CAAR LIN)
20))
(ELT NODE (CDAR LIN))
(ELT NODE (IPLUS (CDAR LIN)
20]
(RETURN (REVERSE X])
(CKINT
[LAMBDA (Z RI X1 X2 Y1 Y2 SL1 YT1 A1 A2 B1 B2)
(PROG (SL2 X YT2)
(SETQ SL2 (SLOPE A1 A2 B1 B2))
[SETQ X (IDIFFERENCE (ITIMES (CAR SL1)
(CDR SL2))
(ITIMES (CAR SL2)
(CDR SL1]
(COND
((ZEROP X)
(GO A))
(Z (RETURN T))
(RI (RETURN T)))
(SETQ X (CLCINT X1 Y1 X2 Y2 A1 B1 A2 B2))
[COND
((EQ X1 X2)
(GO C))
((EQ A1 A2)
(GO B))
(T (RETURN (AND (CLCINTA X A1 A2)
(CLCINTA X X1 X2]
B (COND
((CLCINTA X X1 X2)
(RETURN T)))
(SETQ X (CLCINT Y1 X1 Y2 X2 B1 A1 B2 A2))
(RETURN (CLCINTA X B1 B2))
C (COND
((CLCINTA X A1 A2)
(RETURN T)))
(SETQ X (CLCINT Y1 X1 Y2 X2 B1 A1 B2 A2))
(RETURN (CLCINTA X Y1 Y2))
A (SETQ YT2 (YINTCP A1 A2 B1 B2))
[SETQ X (IDIFFERENCE (ITIMES (CAR YT1)
(CDR YT2))
(ITIMES (CAR YT2)
(CDR YT1]
(COND
([OR (NOT (ZEROP X))
(AND (ZEROP (CDR YT1))
(ZEROP (CDR YT2))
(NOT (EQ X1 A1]
(RETURN T)))
(RETURN (COND
[(EQ X1 X2)
(OR (GEQ (MIN Y1 Y2)
(MAX B1 B2))
(GEQ (MIN B1 B2)
(MAX Y1 Y2]
(T (OR (GEQ (MIN X1 X2)
(MAX A1 A2))
(GEQ (MIN A1 A2)
(MAX X1 X2])
(SLOPE
[LAMBDA (X1 X2 Y1 Y2)
(CONS (IDIFFERENCE X1 X2)
(IDIFFERENCE Y1 Y2])
(SRTLNA
[LAMBDA (X Y Y1)
(PROG NIL
(COND
((MEMBER X Y)
(RETURN Y)))
(SETA TMP X (PLUS Y1 (ELT TMP X)))
(RETURN (CONS X Y])
)
(DEFINEQ
(DRAW
[LAMBDA (STRUC RAD)
(PROG (O CTAB (TITLE ""))
(COND
((STRUCTURE? STRUC)
(DRAWS STRUC))
[(STRUCTURE? (CAR STRUC))
(DRAWS (CAR STRUC))
(MAPC (CDR STRUC)
(FUNCTION (LAMBDA (X)
(PAUSE)
(DRAWS X]
((EQ RAD T)
(PRINRAD STRUC))
[(EQ RAD (QUOTE L))
(PRINRAD (CAR STRUC))
(MAPC (CDR STRUC)
(FUNCTION (LAMBDA (XZ)
(PAUSE)
(PRINRAD XZ]
[(EQ RAD (QUOTE AL))
[COND
[(STRUCTURE? (CDAR STRUC))
(DRAWS (CDAR STRUC)
(LIST (QUOTE STRUCTURE)
(QUOTE #)
(CAAR STRUC]
(T [SETQ TITLE (LIST (APPEND (QUOTE (STRUCTURE #))
(CAAR STRUC]
(PRINRAD (CDAR STRUC]
(MAPC (CDR STRUC)
(FUNCTION (LAMBDA (S)
(PAUSE)
(COND
[(STRUCTURE? (CDR S))
(DRAWS (CDR S)
(LIST (QUOTE STRUCTURE)
(QUOTE #)
(CAR S]
(T (SETQ TITLE (APPEND (QUOTE (STRUCTURE
#))
(CAR S)))
(PRINRAD (CDR S]
(T (ERROR "BAD STRUCTURE"])
(DRAWS
[LAMBDA (STRUC ID)
(PROG (CTAB)
(SETQ CTAB (CTABLE STRUC))
(LAYOUT
(CONS (OR ID (UGRAPH STRUC))
(MAPCAR
CTAB
(FUNCTION (LAMBDA (CTE)
(CONS (NODENUM CTE)
(CONS (ATOMTYPE (MARKERS CTE))
(SUBSET
(NBRS CTE)
(FUNCTION (LAMBDA (X)
(NOT (EQ X (QUOTE FV])
(PRINRAD
[LAMBDA (L)
(PROG (CTAB)
(PRINRAD1 NIL (FOR NEW I :=((NUMNODES L)
1 -1)
XLIST I)
L)
(LAYOUT (CONS TITLE CTAB])
(PRINENTRY
[LAMBDA (N AT CON)
(SETQ CTAB (CONS (CONS N (CONS AT CON))
CTAB])
(PAUSE
[LAMBDA NIL
(PROG NIL
LP (PRIN1 "READY ? ")
(COND
((RESETVAR DWIMWAIT 10 (EQ (Y/N Y)
(QUOTE Y)))
(RETURN))
(T (GO LP])
)
(DEFINEQ
(/ONCOC
[LAMBDA (CHARS)
(SETQ CHARS (ONCOC CHARS))
(UNDOSAVE (LIST (QUOTE SFCOC)
T
(CAR CHARS)
(CDR CHARS)))
CHARS])
(RESETCOC
[NLAMBDA (CHARS FORM)
(EVAL (SUBPAIR (QUOTE (FORM CHARS))
(LIST FORM CHARS)
(QUOTE (PROG (MACROX MACROY)
(SETQ MACROX (ONCOC CHARS))
(SETQ MACROX
(SETQ RESETVARSLST
(CONS (LIST (LIST (QUOTE SFCOC)
T
(CAR MACROX)
(CDR MACROX)))
RESETVARSLST)))
(SETQ MACROY (XNLSETQ FORM))
(SETQ RESETVARSLST (CDR MACROX))
(APPLY (QUOTE SFCOC)
(CDAAR MACROX))
[COND
(MACROY (RETURN (CAR MACROY]
(ERROR!])
(SFCOC
[LAMBDA (FILE N M)
(ASSEMBLE NIL
(CQ (VAG (OPNJFN FILE)))
(PUSHN)
(CQ (VAG N))
(PUSHN)
(CQ (VAG M))
(MOVE 3 , 1)
(POP NP , 2)
(POPN)
(JSYS 75) (* SFCOC)
(CQ T])
(SETCOC
[LAMBDA (N VAL)
(PROG ([N (OR (NUMBERP N)
(CAR (CHCON N]
(V (RFCOC T)))
(COND
((IGREATERP N 17)
(SFCOC T (CAR V)
(M (CDR V)
(IDIFFERENCE N 18)
VAL))
(RFCOC T))
(T (SFCOC T (M (CAR V)
N VAL)
(CDR V))
(RFCOC T])
(M
[LAMBDA (W V I)
(LOGOR (LOGAND W (LOGXOR (LSH 3 (IDIFFERENCE 34 (ITIMES V 2)))
-1))
(LSH I (IDIFFERENCE 34 (ITIMES V 2])
(RFCOC
[LAMBDA (FILE)
(ASSEMBLE NIL
(CQ (VAG (OPNJFN FILE)))
(JSYS 74) (* RFCOC)
(PUSH NP , 3)
(MOVE 1 , 2)
(CQ (CONS (LOC (AC))
(LOC (ASSEMBLE NIL
(POPN])
(PRINBRIT
[LAMBDA (X)
(SETCOC 14 2)
(SETCOC 15 2)
(PRIN1 "∞")
(PRIN1 X)
(PRIN1 (CHARACTER 15])
(CLEAR
[LAMBDA NIL
(SETCOC 26 2)
(SETCOC 24 2)
(PRIN1 "_~~~~~~~~~~~~~~~")
(SETCOC 24 1)
(SETCOC 26 1])
(ONCOC
[LAMBDA (CHARS)
(PROG ((N (SELECTQ (NTYP CHARS)
[8 (MAPCAR CHARS (FUNCTION (LAMBDA (X)
(OR (AND (SMALLP X)
X)
(CAR (CHCON X]
((12 24 28)
(CHCON CHARS))
(20 (LIST CHARS))
(ERROR "FUNNY ARG TO ONCOC:" CHARS)))
(V (RFCOC T))
V1 V2)
(SETQ V1 (CAR V))
(SETQ V2 (CDR V))
[MAPC N (FUNCTION (LAMBDA (N1)
(COND
((IGREATERP N1 17)
(SETQ V2 (M V2 (IDIFFERENCE N1 18)
2)))
(T (SETQ V1 (M V1 N1 2]
(SFCOC T V1 V2)
(RETURN V])
)
(DEFLIST(QUOTE(
[RESETCOC ((CHARS FORM)
(PROG (MACROX MACROY)
(SETQ MACROX (ONCOC CHARS))
(SETQ MACROX (SETQ
RESETVARSLST
(CONS (LIST (LIST (QUOTE SFCOC)
T
(CAR MACROX)
(CDR MACROX)))
RESETVARSLST)))
(SETQ MACROY (XNLSETQ FORM))
(SETQ RESETVARSLST (CDR MACROX))
(APPLY (QUOTE SFCOC)
(CDAAR MACROX))
[COND (MACROY (RETURN (CAR MACROY]
(ERROR!]
))(QUOTE MACRO))
STOP